home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
PGM_TOOL
/
PREVIEW
/
MISC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-11-12
|
10KB
|
427 lines
Unit Misc;
Interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, wYNform;
Const MaxPars=20;
UPARROW=38; { in KeyDown events, GetUp(),GetDown(),GetEsc() }
DNARROW=40;
ESCKEY=27;
RETKEY=13;
RETCHAR=#13; { in KeyPress events, GetRet() }
NULLCHAR=#0;
DNCHAR=#40;
UPCHAR=#38;
ESCCHAR=#27;
Type
String135=String[137];
String30=String[31];
GenVars=class(TObject)
public
{ used to store BluePrint Images }
User:string[10];
FullBP,TinyBP,PrintBP:TBitMap;
InBluePrint:boolean; { only allow one open at a time }
procedure AddWin(astr:string;aform:Tform);
procedure ReleaseWin(aform:Tform);
end;
procedure StartMisc;
procedure StopMisc;
function Pin(str1,instr2:string):boolean; { pos()>0 }
function uPin(str1,instr2:string):boolean; { pos()>0 }
function YesNoBox(text:string):boolean;
function iifs(abool:boolean;ret1,ret2:string):string;
function Empty(aStr:String):Boolean;
function ProcInt(nval:string):integer;
function ProcDbl(nval:string):double;
procedure split(orgline,pchar:string;
var resarr:array of string135;var rescnt:integer);
function Trim(aStr:String):String; { trim off trailing spaces }
function pp(var anInt:integer):integer; { ii:=ii+1 ==> pp(ii) }
function iifi(abool:boolean;ret1,ret2:integer):integer;
function lTrim(aStr:String):String; { trim off leading spaces }
procedure OKbox(sText:String);
function GetRet(var aChar:char):boolean;
function PadR(aStr:String;InWidth:Integer):String; { left justify in width }
function Space(EmptySize:Integer):String; { return string of spaces }
procedure MouseWait;
procedure MouseGo;
procedure CenterHoriz(aform:Tform);
function Upper(aStr:string):string;
function SubStr(astr:string;fromm,too:integer):string;
function unsplit(var arr1:array of string135;delim:string;acnt:integer):string;
function StrD(aDbl:double;ToPlaces:integer):string;
function Str(aDbl:double;width,decs:integer):string;
function StrI(aInt:longint;width:integer):string;
function ComPath(aFile:string):string;
function PadL(aStr:String;InWidth:Integer):String; { right justify in width }
procedure DoEvents;
procedure DoEvents2;
var Gen:GenVars;
Implementation
function ComPath(aFile:string):string;
begin
result:=aFile;
end;
function PadL(aStr:String;InWidth:Integer):String; { right justify in width }
var ll:integer;
begin
ll:=length(aStr);
if ll>=InWidth then Result:=copy(aStr,1,Inwidth) { truncate }
else Result:=space(InWidth-ll)+aStr;
end;
procedure DoEvents;
begin
Application.ProcessMessages;
end;
procedure DoEvents2;
begin
Application.ProcessMessages;
end;
function str(aDbl:double;width,decs:integer):string;
var nines,before,after:string[30];
ii:integer;
begin
Result:=format('%*.*f',[width,decs,aDbl]);
end;
function StrI(aInt:longint;width:integer):string;
begin
result:=padl(inttostr(aInt),width);
end;
function StrD(aDbl:double;ToPlaces:integer):string;
var InWidth:integer;
begin
InWidth:=8;
if ToPlaces>0 then InWidth:=8+1+ToPlaces;
Result:=ltrim(str(aDbl,InWidth,ToPlaces));
end;
function unsplit(var arr1:array of string135;delim:string;acnt:integer):string;
{ array may be 1 based, but when passed in it becomes 0 based }
var ii,jj,pp:integer;
tt:string;
begin
tt:='';
if acnt=1 then begin
tt:=arr1[0];
End;
if acnt>1 then begin
for ii:=0 to acnt-2 do begin
tt:=tt+arr1[ii]+delim;
End;
tt:=tt+arr1[acnt-1];
End;
Result:=tt;
end;
function SubStr(astr:string;fromm,too:integer):string;
begin
result:=copy(astr,fromm,too);
end;
procedure GenVars.AddWin(astr:string;aform:Tform);
begin
{ do nothing }
end;
procedure GenVars.ReleaseWin(aform:Tform);
begin
{ do nothing }
end;
function Upper(aStr:string):string;begin
result:=uppercase(aStr);
end;
procedure CenterHoriz(aform:Tform);
var ii:integer;
begin
ii:=(screen.width-aform.width-8) div 2;
if ii<0 then aform.left:=0 else aform.left:=ii;
end;
procedure MouseWait;
begin
Screen.Cursor:=crHourGlass;
Application.ProcessMessages;
end;
procedure MouseGo;
begin
Screen.Cursor:=crDefault;
Application.ProcessMessages;
end;
function Space(EmptySize:Integer):String; { return string of spaces }
var tt,tt2:string;
ii:integer;
begin
tt:=' ';
tt2:='';
for ii:=1 to 5 do tt2:=tt2+tt;
ii:=length(tt2);
Result:=copy(tt2,1,EmptySize);
end;
function PadR(aStr:String;InWidth:Integer):String; { left justify in width }
var ll:integer;
begin
ll:=length(aStr);
if ll>=InWidth then Result:=copy(aStr,1,Inwidth) { truncate }
else Result:=aStr+space(InWidth-ll);
end;
function GetRet(var aChar:char):boolean;
begin
if aChar=escchar then aChar:=nullchar;
if aChar=retchar then begin
aChar:=nullchar;
Result:=true;
end else Result:=false;
end;
procedure OKbox(sText:String);
var tyn:TYNform;
begin
tyn:=TYNform.create(application);
tyn.setup(1,'Job Cost',stext);
tyn.showmodal;
end;
function lTrim(aStr:String):String; { trim off trailing spaces }
var ii,kk,ll:integer;
begin
ll:=length(aStr);
Result:=aStr;
if ll>0 then begin
kk:=0;
for ii:=1 to ll do begin
if aStr[ii]<>#32 then begin
kk:=ii;
break;
end;
end;
if kk>0 then Result:=copy(astr,kk,254)
else Result:='';
end;
end;
function iifi(abool:boolean;ret1,ret2:integer):integer;
{ iif() when params are integer's }
begin
if abool then result:=ret1 else result:=ret2;
end;
function pp(var anInt:integer):integer; { ii:=ii+1 ==> pp(ii) }
begin
result:=anInt; { usage: lp.p(line++,5,'Hi') -> lp.p(pp(line),5,'Hi') }
anInt:=anInt+1;
end;
function Pin(str1,instr2:string):boolean; { pos()>0 }
begin
result:=(pos(str1,instr2)>0);
end;
function uPin(str1,instr2:string):boolean; { pos()>0 }
begin
result:=(pos(upper(str1),upper(instr2))>0);
end;
function YesNoBox(text:string):boolean;
var ret:integer;
tyn:TYNform;
begin
tyn:=TYNform.create(application);
tyn.setup(2,'Job Cost',text);
ret:=tyn.showmodal;
Result:=(ret=mrYES);
end;
function iifs(abool:boolean;ret1,ret2:string):string;
{ iif() when params are string's }
begin
if abool then result:=ret1 else result:=ret2;
end;
procedure StartMisc;
begin
Gen:=genvars.create;
Gen.User:='BRAD ';
Gen.FullBP:=tbitmap.create;
Gen.TinyBP:=tbitmap.create;
Gen.PrintBP:=tbitmap.create;
end;
procedure StopMisc;
begin
Gen.free;
Gen.FullBP.free;
Gen.TinyBP.free;
Gen.PrintBP.free;
end;
function Empty(aStr:String):Boolean;
var ii,ll:integer;
res:boolean;
begin
if length(aStr)=0 then res:=true
else
begin
ll:=length(aStr);
if (ll=8) or (ll=10) then { check for date? }
begin
if (aStr[3]=#47) and (aStr[6]=#47) then { chars 3 and 6 are "/" }
begin
ll:=2; { only need to test first 2 chars of dates }
if pos('00',aStr)=1 then ll:=0 { ignore '00/00/00' }
end;
end;
res:=True;
if ll>0 then begin
for ii:=1 to ll do begin
if aStr[ii]<>#32 then begin
res:=False;
break;
end;
end;
end;
end;
Result:=res;
end;
function ProcInt(nval:string):integer;
var tdbl:double;
begin
tdbl:=ProcDbl(nval);
result:=StrToInt(format('%8.0f',[tdbl]));
end;
function procdbl(nval:string):double;
var decs,prnum,jj:double;
ii:integer;
ist:string[30];
pastdec,isminus:boolean;
begin
prnum:=0.00;
pastdec:=False;
isminus:=False;
decs:=1.0;
if not empty(nval) then begin
for ii:=1 to length(nval) do begin
ist:=Copy(nval,ii,1);
if ist='-' then begin
isminus:=True;
End;
if ist='.' then begin
pastdec:=True;
End Else
Begin
if (ist >= '0') And (ist <= '9') then begin
jj:=StrToFloat(ist);
prnum := prnum * 10.0;
prnum := prnum + jj;
if pastdec then begin
decs:=decs / 10.0;
End;
End;
End;
End;
if isminus then begin
prnum:=prnum * decs * -1;
End Else
Begin
prnum:=prnum * decs;
End;
if Not pastdec then begin
prnum:=int(prnum);
End;
end;
Result:=prnum;
end;
procedure split(orgline,pchar:string;
var resarr:array of string135;var rescnt:integer);
var aline:string;
ii,jj,kk,acnt,plen:integer;
ats:array [1..80] of integer;
begin
for ii:=0 to high(resarr) do resarr[ii]:='';
rescnt:=0;
for ii:=1 to 80 do ats[ii]:=0;
aline:=orgline;
jj:=length(aline);
plen:=length(pchar);
if jj>0 then begin
rescnt:=1;
ats[rescnt]:=0;
for ii:=1 to jj do begin
if Copy(aline,ii,plen)=pchar then begin
rescnt:=rescnt+1;
ats[rescnt]:=ii;
End;
End;
ats[rescnt+1]:=jj;
if rescnt=1 then begin
resarr[0]:=aline;
End Else
Begin
for ii:=1 to rescnt do begin
if ii=1 then begin
kk:=ats[ii+1]-ats[ii]-1;
if kk>0 then begin
resarr[ii-1]:=Copy(aline,1,kk);
End;
end else
if ii=rescnt then begin
kk:=ats[ii+1]-ats[ii]-plen+1;
if kk>0 then begin
resarr[ii-1]:=Copy(aline,ats[ii]+plen,kk);
End;
end Else
begin
kk:=ats[ii+1]-ats[ii]-plen;
if kk>0 then begin
resarr[ii-1]:=Copy(aline,ats[ii]+plen,kk);
End;
End;
End;
End;
End;
end;
function Trim(aStr:String):String; { trim off trailing spaces }
var ii,kk,ll:integer;
begin
ll:=length(aStr);
Result:=aStr;
if ll>0 then begin
kk:=0;
for ii:=ll downto 1 do begin
if aStr[ii]<>#32 then begin
kk:=ii;
break;
end;
end;
if kk>0 then Result:=copy(astr,1,kk)
else Result:='';
end;
end;
end.